Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Snippets/PNL Libraries/MyInternetConfig.p

Text File | 1997-02-26 | 12.8 KB | 474 lines | [TEXT/CWIE]

unit MyInternetConfig;

interface

    uses
        Types,
        ICTypes, ICKeys;

    var
        has_IC: boolean;
        internet_config_instance: ICInstance;

    procedure StartupInternetConfig;
    procedure ConfigureInternetConfig(creator: OSType; required: Boolean);
    function GetFilenameInfo (name: Str255; var entry: ICMapEntry; istext: boolean): boolean;
{ NOTE: entry will always be valid as a "best guess"}
    function GetCreatorTypeInfo (fcreator, ftype: OSType; name: Str255; var entry: ICMapEntry): boolean;
{ NOTE: entry will always be valid as a "best guess"}
    function GetTextCreator: OSType; { DONT USE FOR EDITOR HELPER! }
    procedure GetBinaryCreator;
    function GetTextHelper: OSType;
    function GetHelper (name: Str255; var app: ICAppSpec): OSErr;
    function GetICString (const key: Str255; var data: Str255): OSErr;
    function GetICStr (const key: Str255): Str255;
    function SetICString (const key: Str255; data: Str255): OSErr;
    function GetICBoolean( const key: Str255; var result: Boolean ): OSErr;
    function GetICBool( const key: Str255 ): Boolean;
    function SetICBoolean( const key: Str255; result: Boolean ): OSErr;
    function MyICBegin (perm: ICPerm): OSErr;
    function MyICEnd: OSErr;
    function LaunchInternetConfig:OSErr;
    function CheckICUsageVersion(component_version:longint): OSErr;
    function MyLaunchURL(hint,url:Str255): OSErr;
    function SafeICGetPrefHandle (inst: ICInstance; const key: Str255; var attr: ICAttr; var prefh: Handle): ICError;
    procedure GetFontSize (key1,key2:Str255; deffont,defsize:integer; var font, size: integer);
    procedure GetScreenFontSize (var font, size: integer);
    procedure GetListFontSize (var font, size: integer);

implementation

    uses
        TextUtils, Errors, Components, Fonts, Memory, Events,
        MyMemory, MySystemGlobals, MyUtils, ICAPI, MyStrings, MyProcesses, MyStartup;

    const
        IC_first_entry_pos = 0;

{$ifc do_debug}
    var
        startup_check: integer;
{$endc}

    var
        map_handle: Handle;
        ic_seed: longint;
        text_creator: OSType;
        binary_creator: OSType;
        binary_type: OSType;
        binary_creator_app_name:Str63;
        last_checked:longint;
        g_creator: OSType;
        g_required: Boolean;

    function SafeICGetPrefHandle (inst: ICInstance; const key: Str255; var attr: ICAttr; var prefh: Handle): ICError;
        var
            err, junk:ICError;
            size: longint;
            did_begin: boolean;
    begin
        prefh := nil;
        err := ICFindPrefHandle(inst, key, attr, prefh);
        if err <> noErr then begin
            did_begin := ICBegin(inst, icReadOnlyPerm) = noErr;
            err := ICGetPref(inst, key, attr, nil, size);
            if err = noErr then begin
                err := MNewHandle( prefh, size );
                if err = noErr then begin
                    HLock(prefh);
                    err := ICGetPref(inst, key, attr, prefh^, size);
                    HUnlock(prefh);
                end;
            end;
            if did_begin then begin
                junk := ICEnd(inst);
            end;
        end;
        if err <> noErr then begin
            MDisposeHandle( prefh );
            prefh := nil;
        end;
        SafeICGetPrefHandle := err;
    end;

    function ICMapErr (icerr: ICError): OSErr;
    begin
        AssertDidStartup( startup_check );
        if (icerr < -32768) or (icerr > 32767) then begin
            icerr := icInternalErr;
        end; (* if *)
        ICMapErr := icerr;
    end; (* ICMapErr *)

    function MyLaunchURL(hint,url:Str255): OSErr;
        var
            start,fin:longint;
    begin
        AssertDidStartup( startup_check );
        MyLaunchURL := -1;
        if has_IC then begin
            start := 0;
            fin := length(url);
            MyLaunchURL := ICMapErr(ICLaunchURL (internet_config_instance,hint, @url[1],length(url), start,fin));
        end;
    end;

    function CheckICUsageVersion(component_version:longint): OSErr;
        var
            err: OSErr;
            component_instance: ComponentInstance;
    begin
        err := ICMapErr(ICGetComponentInstance(internet_config_instance, component_instance));
        if err = noErr then begin
            if BAND(GetComponentVersion(component_instance), $FFFF0000) < BAND(component_version, $FFFF0000) then begin
                err := unimpErr;
            end;
        end else begin
            err := noErr; { we work fine without a component, we just can't deal with an old component }
        end;
        CheckICUsageVersion := err;
    end;

    function LaunchInternetConfig:OSErr;
    begin
        LaunchInternetConfig:= ICMapErr(ICEditPreferences (internet_config_instance,''));
    end;

    function MyGetMapHandle (var hhhh: Handle): boolean;
        var
            seed: longint;
            junk: ICError;
            junk_attr: longint;
    begin
        AssertDidStartup( startup_check );
        if (map_handle <> nil) then begin
            if last_checked<TickCount-120 then begin
                if (ICGetSeed(internet_config_instance, seed) <> noErr) | (seed <> ic_seed) then begin
                    MDisposeHandle(map_handle);
                end else begin
                    last_checked:=TickCount;
                end;
            end;
        end;

        if (map_handle = nil) then begin
            junk := SafeICGetPrefHandle( internet_config_instance, kICMapping, junk_attr, map_handle);
            if (map_handle <> nil) & (ICGetSeed(internet_config_instance, seed) = noErr) then begin
                text_creator := OSType(0);
                binary_creator := OSType(0);
                ic_seed := seed;
            end;
        end;
        hhhh := map_handle;
        MyGetMapHandle := hhhh <> nil;
    end;

    function GetHelper (name: Str255; var app: ICAppSpec): OSErr;
        var
            err: OSErr;
            attr: ICAttr;
            prefsize: longint;
    begin
        if has_IC then begin
            prefsize := SizeOf(ICAppSpec);
            err := ICMapErr(ICGetPref(internet_config_instance, concat(kICHelper, name), attr, @app, prefsize));
            if (err = noErr) & ((prefsize < 5) | (prefsize < 5 + length(app.name))) then begin
                err := badExtResource;
            end;
        end else begin
            err := -1;
        end;
        GetHelper := err;
    end;

    function GetTextHelper: OSType;
        var
            app:ICAppSpec;
    begin
        if GetHelper('editor',app)=noErr then begin
            GetTextHelper:=app.fCreator;
        end else begin
            GetTextHelper:='ttxt';
        end;
    end;

    function GetTextCreator: OSType;
        var
            dummy: boolean;
            entry: ICMapEntry;
            map:Handle;
    begin
        dummy:= MyGetMapHandle (map); { reset text_creator if the Handle has changed }
        if text_creator = OSType(0) then begin
            dummy := GetCreatorTypeInfo('ttxt', 'TEXT', 'file.txt', entry);
            text_creator := entry.file_creator;
        end;
        GetTextCreator := text_creator;
    end;

    procedure GetBinaryCreator; { WARNING: GetBinaryCreator calls GetFilenameInfo calls GetBinaryCreator }
        var
            dummy: boolean;
            entry: ICMapEntry;
            map:Handle;
    begin
        dummy:= MyGetMapHandle (map); { reset binary_creator if the Handle has changed }
        if binary_creator = OSType(0) then begin
            binary_creator := 'hDmp'; { WARNING: we must set binary_creator to avoid unending recursion! }
            binary_type := 'BINA';
            binary_creator_app_name := 'HexEdit';
            if GetFilenameInfo('file.binary', entry, false) then begin
                binary_creator := entry.file_creator;
                binary_type := entry.file_type;
                binary_creator_app_name := entry.creator_app_name;
            end;
        end;
    end;

    function GetCreatorTypeInfo (fcreator, ftype: OSType; name: Str255; var entry: ICMapEntry): boolean;
        var
            found:boolean;
            entries: Handle;
    begin
        found := false;
        if has_IC & MyGetMapHandle(entries) then begin
            found:=ICMapEntriesTypeCreator(internet_config_instance, entries, ftype, fcreator, name, entry)= noErr;
        end;
        if not found then begin
            entry.file_type := ftype;
            entry.file_creator := fcreator;
            entry.creator_app_name := OSTypeToString(fcreator);
            if ftype = 'TEXT' then begin
                entry.flags := ICmap_data_fork_bit;
                entry.MIME_type := 'text/plain';
                entry.entry_name := 'Text File';
            end else begin
                entry.flags := ICmap_binary_bit + ICmap_data_fork_bit;
                entry.MIME_type := 'application/octet-stream';
                entry.entry_name := 'Binary File';
            end;
            entry.post_creator := OSType(0);
            entry.extension := '';
            entry.post_app_name := '';
        end;
        GetCreatorTypeInfo := found;
    end;

    function GetFilenameInfo (name: Str255; var entry: ICMapEntry; istext: boolean): boolean;
        var
            found: boolean;
            entries: Handle;
            temp_name:Str255;
    begin
        found := false;
        if has_IC & MyGetMapHandle(entries) then begin
            found:= ICMapEntriesFilename(internet_config_instance, entries, name, entry) = noErr;
            if not found & (name <> '') & (name[length(name)]='~') then begin
                temp_name := TPcopy(name, 1, length(name)-1);
                found:= ICMapEntriesFilename(internet_config_instance, entries, temp_name, entry) = noErr;
            end;
        end;
        if not found then begin
            if IsExtension(name, '.txt') or istext then begin
                entry.file_type := 'TEXT';
                entry.file_creator := GetTextCreator;
                entry.flags := ICmap_data_fork_mask;
                entry.creator_app_name := 'SimpleText';
                entry.MIME_type := 'text/plain';
                entry.entry_name := 'Text File';
            end else begin
                GetBinaryCreator;
                entry.file_type := binary_type;
                entry.file_creator := binary_creator;
                entry.creator_app_name := binary_creator_app_name;
                entry.flags := ICmap_binary_mask + ICmap_data_fork_mask;
                entry.MIME_type := 'application/octet-stream';
                entry.entry_name := 'Binary File';
            end;
            entry.post_creator := OSType(0);
            entry.extension := '';
            entry.post_app_name := '';
        end;
        GetFilenameInfo := found;
    end;

    function GetICString (const key: Str255; var data: Str255): OSErr;
        var
            err:OSErr;
            size: longint;
            junk_attr: ICAttr;
    begin
        AssertDidStartup( startup_check );
        if has_IC then begin
            size := 256;
            err := ICMapErr(ICGetPref(internet_config_instance, key, junk_attr, @data, size));
        end else begin
            err := -1;
        end;
        if err<>noErr then begin
            data:='';
        end;
        GetICString:=err;
    end;

    function GetICStr (const key: Str255): Str255;
        var
            data: Str255;
            junk: OSErr;
    begin
        junk := GetICString(key, data);
        GetICStr := data;
    end;

    function SetICString (const key: Str255; data: Str255): OSErr;
    begin
        SetICString := ICMapErr(ICSetPref(internet_config_instance, key, ICattr_no_change, @data, length(data) + 1));
    end;

    function SetICBoolean( const key: Str255; data: Boolean ): OSErr;
        var
            n: UInt16;
    begin
        if data then begin
            n := $0101;
        end else begin
            n := 0;
        end;
        SetICBoolean := ICMapErr(ICSetPref(internet_config_instance, key, ICattr_no_change, @n, 1));
    end;

    function GetICBoolean( const key: Str255; var result: Boolean ): OSErr;
        var
            data: integer;
            err: OSErr;
            junk_attr: ICAttr;
            size: longint;
    begin
        AssertDidStartup( startup_check );
        err := -1;
        if has_IC then begin
            data := 0;
            size := 1;
            err := ICMapErr( ICGetPref (internet_config_instance, key, junk_attr, @data, size ) );
            if (err = noErr) & (size <> 1) then begin
                err := -1;
            end;
        end;
        if err = noErr then begin
            result := data <> 0;
        end else begin
            result := false;
        end;
        GetICBoolean := err;
    end;

    function GetICBool( const key: Str255 ): Boolean;
        var
            junk: OSErr;
            result: Boolean;
    begin
        junk := GetICBoolean( key, result );
        GetICBool := result;
    end;

    procedure GetFontSize (key1,key2:Str255; deffont,defsize:integer; var font, size: integer);
        var
            junk_attr: ICAttr;
            fr: ICFontRecord;
            frsize: longint;
            err:ICError;
    begin
        AssertDidStartup( startup_check );
        frsize := SizeOf(fr);
        err:=ICGetPref(internet_config_instance, key1, junk_attr, @fr, frsize);
        if err<>noErr then begin
            frsize := SizeOf(fr);
            err:=ICGetPref(internet_config_instance, key2, junk_attr, @fr, frsize);
        end;
        if err=noErr then begin
            GetFNum(fr.font, font);
            size := fr.size;
        end else begin
            font := deffont;
            size := defsize;
        end;
    end;

    procedure GetScreenFontSize (var font, size: integer);
    begin
        GetMyFonts(MFT_Monaco9, font, size);
        GetFontSize(kICScreenFont, kICListFont, font, size, font, size);
    end;

    procedure GetListFontSize (var font, size: integer);
    begin
        GetMyFonts(MFT_Geneva9, font, size);
        GetFontSize(kICListFont,kICScreenFont, font, size, font, size);
    end;

    function MyICBegin (perm: ICPerm): OSErr;
    begin
        MyICBegin := ICMapErr(ICBegin(internet_config_instance, perm));
    end;

    function MyICEnd: OSErr;
    begin
        MyICEnd := ICEnd(internet_config_instance);
    end;

    function InitMyInternetConfig(var msg: integer): OSStatus;
        var
            junk, err: ICError;
            folders: ICDirSpec;
    begin
{$unused(msg)}
        DidStartup( startup_check );
        last_checked:=TickCount;
        map_handle := nil;
        ic_seed := 0;
        text_creator := OSType(0);
        binary_creator := OSType(0);
        err := ICStart(internet_config_instance, g_creator);
        has_IC := err = noErr;
        if has_IC then begin
            folders.vRefNum := app_fs.vRefNum;
            folders.dirID := app_fs.parID;
            junk := ICFindConfigFile(internet_config_instance, 1, @folders);
        end;
        if not g_required then begin
            err := noErr;
        end;
        InitMyInternetConfig := err;
    end;

    procedure FinishMyInternetConfig;
        var
            junk: ICError;
    begin
        MDisposeHandle(map_handle);
        if has_IC then begin
            junk := ICStop(internet_config_instance);
        end;
    end;

    procedure ConfigureInternetConfig(creator: OSType; required: Boolean);
    begin
        DidStartup( startup_check );
        StartupInternetConfig;
        g_creator := creator;
        g_required := required;
    end;

    procedure StartupInternetConfig;
    begin
        SetStartup(InitMyInternetConfig, nil, 0, FinishMyInternetConfig);
    end;

end.
            if font = 0 then begin
                font := deffont;
            end;
            if size = 0 then begin
                size := defsize;
            end;